home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / iconv8_s.arc / ICONX.ARC / IMAIN.C < prev    next >
Encoding:
C/C++ Source or Header  |  1990-03-28  |  40.7 KB  |  1,689 lines

  1. /*
  2.  * Main program, initialization, termination, and such.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "..\h\config.h"
  7. #include "..\h\rt.h"
  8. #include "rproto.h"
  9. #include "..\h\version.h"
  10. #include "..\h\header.h"
  11. #include "..\h\opdefs.h"
  12. #include <ctype.h>
  13.  
  14. /*
  15.  * Prototype.
  16.  */
  17.  
  18. hidden    novalue    env_err    Params((char *msg,char *name,char *val));
  19.  
  20. /*
  21.  * The following code is operating-system dependent [@imain.01].  Include files
  22.  *  and declarations that are system-dependent.
  23.  */
  24.  
  25. #if PORT
  26. #include <signal.h>
  27.    /* probably needs something more */
  28. Deliberate Syntax Error
  29. #endif                    /* PORT */
  30.  
  31. #if AMIGA
  32. #include <signal.h>
  33. #include <fcntl.h>
  34.  
  35. int chkbreak;                /* if nonzero, check for ^C */
  36. #endif                    /* AMIGA */
  37.  
  38. #if ATARI_ST
  39. #include <fcntl.h>
  40. #endif                    /* ATARI_ST */
  41.  
  42. #if HIGHC_386
  43. #include <system.cf>
  44.  
  45. int _fmode = 0;            /* force CR-LF on std.. files */
  46. #endif                    /* HIGHC_386 */
  47.  
  48. #if MACINTOSH
  49. #include <signal.h>
  50. #if MPW
  51. #include <Types.h>
  52. #include <Events.h>
  53. #include <FCntl.h>
  54. #include <SANE.h>
  55. #include <CursorCtl.h>
  56. int NoOptions = 0;
  57. #endif                    /* MPW */
  58. #endif                    /* MACINTOSH */
  59.  
  60. #if MSDOS
  61. #if !MWC
  62. #include <fcntl.h>
  63. #include <signal.h>
  64. #endif                    /* !MWC */
  65.  
  66. #if MICROSOFT
  67. #include <fcntl.h>
  68. #include <signal.h>
  69. #endif                    /* MICROSOFT */
  70. #endif                    /* MSDOS */
  71.  
  72. #if MVS || VM
  73. #if SASC
  74. #include <lcsignal.h>
  75. #else                    /* SASC */
  76. #include <signal.h>
  77. #endif                    /* SASC */
  78. #endif                    /* MVS || VM */
  79.  
  80. #if OS2
  81. #include <fcntl.h>
  82. #include <signal.h>
  83. #endif                    /* OS2 */
  84.  
  85. #if UNIX
  86. #include <signal.h>
  87. #endif                    /* UNIX */
  88.  
  89. #if VMS
  90. #include <signal.h>
  91. #include <types.h>
  92. #endif                    /* VMS */
  93.  
  94. static char icodebuf[BUFSIZ];
  95.  
  96. /*
  97.  * End of operating-system specific code.
  98.  */
  99.  
  100. #ifdef IconAlloc
  101. #define malloc mem_alloc
  102. #endif                    /* IconAlloc */
  103.  
  104. #ifndef MaxHeader
  105. #define MaxHeader MaxHdr
  106. #endif                    /* MaxHeader */
  107.  
  108. /*
  109.  * A number of important variables follow.
  110.  */
  111.  
  112. static struct b_coexpr *mainhead;    /* &main */
  113. extern struct errtab errtab[];        /* error numbers and messages */
  114.  
  115. #ifdef TraceBack
  116. extern struct b_proc *opblks[];
  117. extern word lastop;            /* last op-code */
  118. extern dptr xargp;
  119. extern word xnargs;            /* number of arguments */
  120.  
  121. #endif                    /* TraceBack */
  122.  
  123.  
  124. #ifdef EvalTrace
  125. word lineno = 0;            /* source line number */
  126. word colmno = 0;            /* source column number */
  127. #endif                    /* EvalTrace */
  128.  
  129. #ifdef DumpIstream
  130. FILE *imons;
  131. #endif                    /* DumpIstream */
  132.  
  133. #ifdef DumpIcount
  134. #define MaxIcode 100
  135. FILE *imonc;
  136. long icode[MaxIcode];
  137. #endif                    /* DumpIcount */
  138.  
  139.  
  140. #ifdef WATERLOO_C_V3_0
  141. extern int *cw3defect;
  142. #endif                    /* WATERLOO_C_V3_0 */
  143.  
  144. #ifdef IconCalling
  145. int IDepth = 0;                /* depth of icon_call calls */
  146. int call_error = 0;            /* called procedure not found */
  147. int interp_status;            /* interpreter status */
  148. #endif                    /* IconCalling */
  149.  
  150. int set_up = 0;                /* initialization switch */
  151. int k_level = 0;            /* &level */
  152. int k_errornumber = 0;            /* &errornumber */
  153. char *k_errortext = "";            /* &errortext */
  154. struct descrip k_errorvalue;        /* &errorvalue */
  155. struct descrip k_main;            /* &main */
  156. char *code;                /* interpreter code buffer */
  157. word *records;                /* pointer to record procedure blocks */
  158. word *ftabp;                /* pointer to record/field table */
  159. dptr fnames, efnames;            /* pointer to field names */
  160. dptr globals, eglobals;            /* pointer to global variables */
  161. dptr gnames, egnames;            /* pointer to global variable names */
  162. dptr statics, estatics;            /* pointer to static variables */
  163. char *strcons;                /* pointer to string constant table */
  164. struct ipc_fname *filenms, *efilenms;    /* pointer to ipc/file name table */
  165. struct ipc_line *ilines, *elines;    /* pointer to ipc/line number table */
  166.  
  167. #ifdef TallyOpt
  168. word tallybin[16];            /* counters for tallying */
  169. int tallyopt = 0;            /* want tally results output? */
  170. #endif                    /* TallyOpt */
  171.  
  172. word mstksize = MStackSize;        /* initial size of main stack */
  173. word stksize = StackSize;        /* co-expression stack size */
  174. struct b_coexpr *stklist;        /* base of co-expression block list */
  175.  
  176. word statsize = MaxStatSize;        /* size of static region */
  177. word statincr = MaxStatSize/4;        /* increment for static region */
  178. char *statbase = NULL;            /* start of static space */
  179. char *statend;                /* end of static space */
  180. char *statfree;                /* static space free pointer */
  181.  
  182. word ssize = MaxStrSpace;        /* initial string space size (bytes) */
  183. char *strbase;                /* start of string space */
  184. char *strend;                /* end of string space */
  185. char *strfree;                /* string space free pointer */
  186. char *currend = NULL;            /* current end of memory region */
  187.  
  188. word abrsize = MaxAbrSize;        /* initial size of allocated block
  189.                        region (bytes) */
  190. char *blkbase;                /* start of block region */
  191. char *blkend;                /* end of allocated blocks */
  192. char *blkfree;                /* block region free pointer */
  193.  
  194. #ifdef FixedRegions
  195. word qualsize = QualLstSize;        /* size of quallist for fixed regions */
  196. #endif                    /* FixedRegions */
  197.  
  198. uword statneed;                /* stated need for static space */
  199. uword strneed;                /* stated need for string space */
  200. uword blkneed;                /* stated need for block space */
  201.  
  202. int dodump;                /* if nonzero, core dump on error */
  203. int noerrbuf;                /* if nonzero, do not buffer stderr */
  204.  
  205. struct descrip k_current;        /* current expression stack pointer */
  206. struct descrip maps2;            /* second cached argument of map */
  207. struct descrip maps3;            /* third cached argument of map */
  208.  
  209. int ntended = 0;            /* number of active tended descrips */
  210.  
  211. #ifdef ExecImages
  212. int dumped = 0;                /* non-zero if reloaded from dump */
  213. #endif                    /* ExecImages */
  214.  
  215. word *stack;                /* Interpreter stack */
  216. word *stackend;             /* End of interpreter stack */
  217.  
  218.  
  219.  
  220. /*
  221.  * Initial icode sequence. This is used to invoke the main procedure with one
  222.  *  argument.  If main returns, the Op_Quit is executed.
  223.  */
  224. word istart[3];
  225. int mterm = Op_Quit;
  226.  
  227. #ifdef IconCalling
  228. int fterm = Op_FQuit;
  229. #endif                    /* IconCalling */
  230.  
  231. #ifndef IconCalling
  232.  
  233.  
  234. novalue main(argc, argv)
  235.  
  236. int argc;
  237. char **argv;
  238.    {
  239.    int i, slen;
  240.  
  241. #if SASC
  242.    quiet(1);                    /* suppress C library diagnostics */
  243. #endif                    /* SASC */
  244.  
  245.    ipc.opnd = NULL;
  246.  
  247. #if VMS
  248.    redirect(&argc, argv, 0);
  249. #endif                    /* VMS */
  250.  
  251.    /*
  252.     * Setup Icon interface.  It's done this way to avoid duplication
  253.     *  of code, since the same thing has to be done if calling Icon
  254.     *  is enabled.  See istart.c.
  255.     */
  256.  
  257. #ifdef CRAY
  258.    argv[0] = "iconx";
  259. #endif                    /* CRAY */
  260.  
  261.    icon_setup(argc, argv, &i);
  262.    while (i--) {            /* skip option arguments */
  263.       argc--;
  264.       argv++;
  265.       }
  266.  
  267.    if (!argc) 
  268.       error("no icode file specified");
  269.    /*
  270.     * Call icon_init with the name of the icode file to execute.    [[I?]]
  271.     */
  272.  
  273.  
  274.    icon_init(argv[1]);
  275.  
  276.    /*
  277.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  278.     *    icode segment, and clear the gfp.
  279.     */
  280.    stackend = stack + mstksize/WordSize;
  281.    sp = stack + Wsizeof(struct b_coexpr);
  282.    ipc.opnd = istart;
  283.    *ipc.op++ = Op_Invoke;                /*    [[I?]] */
  284.    *ipc.opnd++ = 1;
  285.  
  286. #ifdef WATERLOO_C_V3_0
  287.    /*
  288.     *  Workaround for compiler bug.
  289.     */
  290.    cw3defect = ipc.op;
  291.    *cw3defect = Op_Quit;
  292. #else                    /* WATERLOO_C_V3_0 */
  293.    *ipc.op = Op_Quit;
  294. #endif                    /* WATERLOO_C_V3_0 */
  295.  
  296.    ipc.opnd = istart;
  297.    gfp = 0;
  298.  
  299.    /*
  300.     * Set up expression frame marker to contain execution of the
  301.     *  main procedure.  If failure occurs in this context, control
  302.     *  is transferred to mterm, the address of an Op_Quit.
  303.     */
  304.    efp = (struct ef_marker *)(sp);
  305.    efp->ef_failure.op = &mterm;
  306.    efp->ef_gfp = 0;
  307.    efp->ef_efp = 0;
  308.    efp->ef_ilevel = 1;
  309.    sp += Wsizeof(*efp) - 1;
  310.  
  311.    pfp = 0;
  312.    ilevel = 0;
  313.  
  314.    /*
  315.     * The first global variable holds the value of "main".  If it
  316.     *  is not of type procedure, this is noted as run-time error 117.
  317.     *  Otherwise, this value is pushed on the stack.
  318.     */
  319.    if (globals[0].dword != D_Proc)
  320.       fatalerr(-117, NULL);
  321.    PushDesc(globals[0]);
  322.  
  323.    /*
  324.     * Main is to be invoked with one argument, a list of the command
  325.     *  line arguments.    The command line arguments are pushed on the
  326.     *  stack as a series of descriptors and llist is called to create
  327.     *  the list.  The null descriptor first pushed serves as Arg0 for
  328.     *  Ollist and receives the result of the computation.
  329.     */
  330.    PushNull;
  331.    argp = (dptr)(sp - 1);
  332.    for (i = 2; i < argc; i++) {
  333.       slen = strlen(argv[i]);
  334.       strreq((word)slen);
  335.       PushVal(slen);
  336.       PushAVal(alcstr(argv[i],(word)slen));
  337.       }
  338.  
  339.    Ollist(argc - 2, argp);
  340.  
  341.    sp = (word *)argp + 1;
  342.    argp = 0;
  343.  
  344.    set_up = 1;            /* post fact that iconx is initialized */
  345.  
  346.    /*
  347.     * Start things rolling by calling interp.  This call to interp
  348.     *  returns only if an Op_Quit is executed.    If this happens,
  349.     *  c_exit() is called to wrap things up.
  350.     */
  351.  
  352. #ifdef CoProcesses
  353.    codisp();    /* start up co-expr dispatcher, which will call interp */
  354. #else                    /* CoProcesses */
  355.    interp(0,(dptr)NULL);                        /*      [[I?]] */
  356. #endif                    /* CoProcesses */
  357.  
  358.    c_exit(NormalExit);
  359. }
  360. #endif                    /* IconCalling */
  361.  
  362. #ifdef IconCalling
  363. dptr icon_call(pname, argc, dargv)
  364. char *pname;
  365. int argc;
  366. dptr dargv;
  367. {
  368.    int i;
  369.    dptr retdesc;
  370.    struct descrip pd;
  371.  
  372.    if (IDepth == 0)
  373.       {
  374.       /*
  375.        * Perform first-time initializations.
  376.        *  Point sp at word after b_coexpr block for &main, point ipc at initial
  377.        *  icode segment, and clear the gfp.
  378.        */
  379.       stackend = stack + mstksize/WordSize;
  380.       sp = stack + Wsizeof(struct b_coexpr);
  381.       sp--;   /* point at last thing on stack, not beyond it */
  382.  
  383.       interp_status = 0;
  384.       argp = 0;
  385.       pfp = 0;
  386.       ilevel = 0;
  387.       }
  388.  
  389.    /*
  390.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  391.     *    icode segment, and clear the gfp.
  392.     */
  393.    ipc.opnd = istart;
  394.    *ipc.op++ = Op_Invoke;
  395.    *ipc.opnd++ = argc;            /* number of arguments for call */
  396.  
  397. #ifdef WATERLOO_C_V3_0
  398.    /*
  399.     *  Workaround for compiler bug.
  400.     */
  401.    cw3defect = ipc.op;
  402.    *cw3defect = Op_Quit;
  403. #else                    /* WATERLOO_C_V3_0 */
  404.    *ipc.op = Op_Quit;
  405. #endif                    /* WATERLOO_C_V3_0 */
  406.  
  407.    ipc.opnd = istart;
  408.    gfp = 0;
  409.  
  410.    /*
  411.     * Set up expression frame marker to contain execution of the
  412.     *  main procedure.    If failure occurs in this context, control
  413.     *  is transferred to fterm, the address of an Op_FQuit.
  414.     */
  415.    efp = (struct ef_marker *)(sp + 1);
  416.    efp->ef_failure.op = &fterm;     /* signals a failure to interp */
  417.    efp->ef_gfp = 0;
  418.    efp->ef_efp = 0;
  419.    efp->ef_ilevel = ilevel + 1;
  420.    sp += Wsizeof(*efp);
  421.  
  422.    /*
  423.     * "main" is no longer the default starting procedure.
  424.     *  Use procedure named pname as the main (starting) procedure.
  425.     */
  426.    if (getvar(pname,&pd) == Failure) {
  427.       fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname);
  428.       fflush(stderr);
  429.       call_error = 1;
  430.       return (dptr)NULL;
  431.       }
  432.    DeRef(pd);            /* get value (can't fail) */
  433.  
  434.    /*
  435.     * Must be of type procedure.
  436.     */
  437.    if ((pd.dword != D_Proc)) { 
  438.       if (strcmp(pname,"main") == 0 && (pfp == 0))
  439.          fatalerr(-117, NULL);
  440.       else {
  441.          if (pfp == 0)
  442.             fatalerr(-106, NULL);
  443.          else
  444.             fatalerr(106, NULL);
  445.          }
  446.       }
  447.  
  448.    PushDesc(pd);
  449.  
  450.    /*
  451.     * The input arguments are pushed on the stack as a series
  452.     *  of descriptors and the indicated procedure.  The procedure descriptor
  453.     *  is overwritten with the result of the call.
  454.     */
  455.    for (i = 0; i < argc; i++) {           /* i = 0, instead of 2 */
  456.       PushDesc(dargv[i]);
  457.       }
  458.  
  459. /* Pass on value of argp to current invocation.  This will be 0 by
  460.  *  default on the first action, and the value of the current argp on
  461.  *  subsequent invocations.
  462.  */
  463.  
  464.    /*
  465.     * Start things rolling by calling interp.  This call to interp
  466.     *  returns only if an Op_Quit is executed.    If this happens,
  467.     *  return the result of main. (Used to c_exit here).
  468.     */
  469.    IDepth++;
  470.  
  471. #ifdef CoProcesses
  472.    codisp();        /* start up co-expr dispatcher, which calls interp */
  473. #else                    /* CoProcesses */
  474.    interp(0,(dptr)NULL);
  475. #endif                    /* CoProcesses */
  476.  
  477.    IDepth--;
  478.    if (interp_status == A_Pfail_uw)
  479.        return (dptr)NULL;        /* failure no value */
  480.    else                    /* NOTE: suspension not identified */
  481.        {
  482.        retdesc = (dptr)(sp - 1);
  483.        sp = (word *) efp - 1;
  484.        return retdesc;             /* success, return top sp */
  485.        }
  486.  
  487. }
  488. #endif                     /* IconCalling */
  489.  
  490. novalue icon_setup(argc,argv,ip)
  491. int argc;
  492. char **argv;
  493. int *ip;
  494.    {
  495.  
  496. #ifdef TallyOpt
  497.    extern int tallyopt;
  498. #endif                    /* TallyOpt */
  499.  
  500.    *ip = 0;            /* number of arguments processed */
  501.  
  502. #ifdef ExecImages
  503.    if (dumped) {
  504.       /*
  505.        * This is a restart of a dumped interpreter.  Normally, argv[0] is
  506.        *  iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the
  507.        *  arguments to pass as a list to main().  For a dumped interpreter
  508.        *  however, argv[0] is the executable binary, and the first argument
  509.        *  for main() is argv[1].  The simplest way to handle this is to
  510.        *  back up argv to point at argv[-1] and increment argc, giving the
  511.        *  illusion of an additional argument at the head of the list.  Note
  512.        *  that this argument is never referenced.
  513.        */
  514.       argv--;
  515.       argc++;
  516.       (*ip)--;
  517.       }
  518. #endif                    /* ExecImages */
  519.  
  520. #ifdef MaxLevel
  521.    maxilevel = 0;
  522.    maxplevel = 0;
  523.    maxsp = 0;
  524. #endif                    /* MaxLevel */
  525.  
  526. #ifdef DumpIstream
  527.    imons = fopen("icodes.mon",WriteText);
  528.    if (imons == NULL) {
  529.       fprintf(stderr,"cannot open icodes.mon\n");
  530.       fflush(stderr);
  531.       abort();
  532.       }
  533. #endif                    /* DumpIstream */
  534.  
  535. #ifdef DumpIcount
  536.    imonc = fopen("icodec.mon",WriteText);
  537.    if (imonc == NULL) {
  538.       fprintf(stderr,"cannot open icodec.mon\n");
  539.       fflush(stderr);
  540.       abort();
  541.       }
  542. #endif                    /* DumpIcount */
  543.  
  544. #if MACINTOSH
  545. #if MPW
  546.    InitCursorCtl(NULL);
  547.    /*
  548.     * To support the icode and iconx interpreter bundled together in
  549.     * the same file, we might have to use this code file as the icode
  550.     * file, too.  We do this if the command name is not 'iconx'.
  551.     */
  552.    {
  553.    char *p,*q,c,fn[6];
  554.  
  555.    /*
  556.     * Isolate the filename from the path.
  557.     */
  558.    q = strrchr(*argv,':');
  559.    if (q == NULL)
  560.        q = *argv;
  561.    else
  562.        ++q;
  563.    /*
  564.     * See if it's the real iconx -- case independent compare.
  565.     */
  566.    p = fn;
  567.    if (strlen(q) == 5)
  568.       while (c = *q++) *p++ = tolower(c);
  569.    *p = '\0';
  570.    if (strcmp(fn,"iconx") != 0) {
  571.      /*
  572.       * This technique of shifting arguments relies on the fact that
  573.       * argv[0] is never referenced, since this will make it invalid.
  574.       */
  575.       --argv;
  576.       ++argc;
  577.       /*
  578.        * We don't want to look for any command line options in this
  579.        * case.  They could interfere with options for the icon
  580.        * program.
  581.        */
  582.       NoOptions = 1;
  583.       }
  584.    }
  585. #endif                    /* MPW */
  586. #endif                                  /* MACINTOSH */
  587.  
  588. /*
  589.  * Handle command-line options.
  590. */
  591.  
  592. /*
  593.  * Handle command line options.
  594. */
  595. #if MACINTOSH && MPW
  596.    if (!NoOptions)
  597.    while (!NoOptions && argv[1] != 0 && *argv[1] == '-' ) {
  598. #else                    /* MACINTOSH && MPW */
  599.    while ( argv[1] != 0 && *argv[1] == '-' ) {
  600. #endif                    /* MACINTOSH && MPW */
  601.       switch ( *(argv[1]+1) ) {
  602.  
  603. #ifdef TallyOpt
  604.     /*
  605.      * Set tallying flag if -T option given
  606.      */
  607.     case 'T':
  608.         tallyopt = 1;
  609.         break;
  610. #endif                    /* TallyOpt */
  611.  
  612.       /*
  613.        * Set stderr to new file if -e option is given.
  614.        */
  615.      case 'e': {
  616.         char *p;
  617.         if ( *(argv[1]+2) != '\0' )
  618.            p = argv[1]+2;
  619.         else {
  620.            argv++;
  621.            argc--;
  622.                (*ip)++;
  623.            p = argv[1];
  624.            if ( !p )
  625.           error("no file name given for redirection of &errout");
  626.            }
  627.         if ( *p == '-' ) { /* let - be stdout */
  628. /*
  629.  * The following code is operating-system dependent [@imain.02].  Redirect
  630.  *  stderr to stdout.
  631.  */
  632.  
  633. #if PORT
  634.    /* may not be possible */
  635. Deliberate Syntax Error
  636. #endif                    /* PORT */
  637.  
  638. #if AMIGA
  639. #if AZTEC_C
  640.         /*
  641.          * Try the same hack as above for Manx and cross fingers.
  642.          * If it doesn't work, try trick used for HIGH_C, below.
  643.          */
  644.         stderr->_unit  = stdout->_unit;
  645.         stderr->_flags = stdout->_flags;
  646. #endif                    /* AZTEC C */
  647. #if LATTICE
  648.                /*
  649.                 * The following code is for Lattice 4.0.  It was different
  650.                 *  for Lattice 3.10 and probably won't work for other
  651.                 *  C compilers.
  652.                 */
  653.            stderr->_file = 1;
  654.            stderr->_flag = stdout->_flag;
  655. #endif                    /* LATTICE */
  656. #endif                    /* AMIGA */
  657.  
  658. #if ATARI_ST || MSDOS || OS2 || VMS
  659.                dup2(fileno(stdout),fileno(stderr));
  660. #endif                    /* ATARI_ST || MSDOS || OS2 ... */
  661.  
  662. #if HIGHC_386
  663.            /*
  664.             * Don't like doing this, but it seems to work.
  665.             */
  666.            setbuf(stdout,NULL);
  667.            setbuf(stderr,NULL);
  668.            stderr->_fd = stdout->_fd;        
  669. #endif                    /* HIGHC_386 */
  670.  
  671. #if MACINTOSH
  672. #if LSC
  673.    /* cannot do */
  674. #endif                    /* LSC */
  675. #if MPW
  676.                close(fileno(stderr));
  677.                dup(fileno(stdout));
  678. #endif                    /* MPW */
  679. #endif                                  /* MACINTOSH */
  680.  
  681. #if MVS || VM
  682.                /* Cannot do. */
  683. #endif                    /* MVS || VM */
  684.  
  685. #if UNIX
  686.                /*
  687.                 * This relies on the way UNIX assigns file numbers.
  688.                 */
  689.                close(fileno(stderr));
  690.                dup(fileno(stdout));
  691. #endif                    /* UNIX */
  692.  
  693. /*
  694.  * End of operating-system specific code.
  695.  */
  696.  
  697.             }
  698.          else    /* redirecting to named file */
  699.             if (freopen(p, "w", stderr) == NULL)
  700.                syserr("Unable to redirect &errout\n");
  701.         break;
  702.         }
  703.         }
  704.     argc--;
  705.         (*ip)++;
  706.     argv++;
  707.       }
  708.    }
  709.  
  710. /*
  711.  * icon_init - initialize memory and prepare for Icon execution.
  712.  */
  713.  
  714. novalue icon_init(name)
  715. char *name;
  716.    {
  717.    int n;
  718.    struct header hdr;
  719.    FILE *fname = NULL;
  720.    word cbread, longread();
  721.    extern struct astkblk *alcactiv();
  722.  
  723.    /*
  724.     * Catch floating point traps and memory faults.
  725.     */
  726.  
  727. /*
  728.  * The following code is operating-system dependent [@imain.03].  Set traps.
  729.  */
  730.  
  731. #if PORT
  732.    /* probably needs something */
  733. Deliberate Syntax Error
  734. #endif                    /* PORT */
  735.  
  736. #if AMIGA
  737.    signal(SIGFPE,fpetrap);
  738. #endif                    /* AMIGA */
  739.  
  740. #if ATARI_ST
  741. #endif                    /* ATARI_ST */
  742.  
  743. #if HIGHC_386
  744.    /* signals not supported */
  745. #endif                    /* HIGHC_386 */
  746.  
  747. #if MACINTOSH
  748. #if MPW
  749.    /* This is equivalent to SIGFPE signal in the Standard Apple
  750.       Numeric Environment (SANE) */
  751.    {
  752.    environment e;
  753.    getenvironment(&e);
  754. #ifdef mc68881
  755.       e.FPCR |= CURUNDERFLOW|CUROVERFLOW|CURDIVBYZERO;
  756. #else                    /* mc68881 */
  757.       e |= UNDERFLOW|OVERFLOW|DIVBYZERO;
  758. #endif                    /* mc68881 */
  759.    setenvironment(e);
  760. #ifdef mc68881
  761.       {
  762.       static trapvector tv =
  763.          {fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap};
  764.       settrapvector(&tv);
  765.       }
  766. #else                    /* mc6881 */
  767.       sethaltvector((haltvector)fpetrap);
  768. #endif                    /* mc6881 */
  769.    }
  770. #endif                    /* MPW */
  771. #endif                    /* MACINTOSH */
  772.  
  773. #if MSDOS
  774. #if LATTICE || MICROSOFT || TURBO
  775.    signal(SIGFPE, fpetrap);
  776. #endif                    /* LATTICE || MICROSOFT || TURBO */
  777. #endif                    /* MSDOS */
  778.  
  779. #if MVS || VM
  780. #if SASC
  781.    cosignal(SIGFPE, fpetrap);           /* catch in all coprocs */
  782.    cosignal(SIGSEGV, segvtrap);
  783. #endif                    /* SASC */
  784. #ifdef WATERLOO_C_V3_0
  785.    /* Note that the following is the same as SIGFPE except that it
  786.       doesn't capture significance exceptions (caused when ever
  787.       a floating point register is loaded with a 0.0 */
  788.    signal(( _FLOAT_UNDER + _FLOAT_OVER + _FLOAT_DIVIDE), fpetrap);
  789. #endif                    /* WATERLOO_C_V3_0 */
  790. #endif                                  /* MVS || VM */
  791.  
  792. #if OS2
  793.    signal(SIGFPE, fpetrap);
  794.    signal(SIGSEGV, segvtrap);
  795. #endif                    /* OS2 */
  796.  
  797. #if UNIX || VMS
  798.    signal(SIGSEGV, segvtrap);
  799. #ifdef PYRAMID
  800.    {
  801.    struct sigvec a;
  802.  
  803.    a.sv_handler = fpetrap;
  804.    a.sv_mask = 0;
  805.    a.sv_onstack = 0;
  806.    sigvec(SIGFPE, &a, 0);
  807.    sigsetmask(1 << SIGFPE);
  808.    }
  809. #else                    /* PYRAMID */
  810.    signal(SIGFPE, fpetrap);
  811. #endif                    /* PYRAMID */
  812. #endif                    /* UNIX || VMS */
  813.  
  814. /*
  815.  * End of operating-system specific code.
  816.  */
  817.  
  818. #ifdef ExecImages
  819.    /*
  820.     * If reloading from a dumped out executable, skip most of init and
  821.     *  just set up the buffer for stderr and do the timing initializations.
  822.     */
  823.    if (dumped)
  824.        goto btinit;
  825. #endif                    /* ExecImages */
  826.  
  827.    /*
  828.     * Initialize data that can't be intialized statically.
  829.     */
  830.  
  831.    datainit();
  832.  
  833.    /*
  834.     * Open the icode file and read the header.        [[I?]]
  835.     */
  836.  
  837.    if (!name)
  838.       error("no interpreter file supplied");
  839.  
  840.    /*
  841.     * Try adding the suffix if the file name doesn't end in it.
  842.     */
  843.    n = strlen(name);
  844.    if (n <= 4 || (strcmp(name+n-4,IcodeSuffix) != 0)
  845.    && strcmp(name+n-4,IcodeASuffix) != 0) {
  846.       char tname[100];
  847.       if (strlen(name) + 5 > 100)
  848.          error("icode file name too long");
  849.       strcpy(tname,name);
  850.  
  851. #if MVS                 /* for any compiler which allows PDS members */
  852.    {
  853.       char *p;
  854.       if (p = index(name, '(')) {
  855.          tname[p-name] = '\0';
  856.       }
  857. #endif                    /* MVS */
  858.  
  859. #ifdef WATERLOO_C_V3_0
  860.       strcat(tname," ICX * (BIN");
  861.       fname = fopen(tname,ReadText);
  862. #else                                   /* WATERLOO_C_V3_0 */
  863.       strcat(tname,IcodeSuffix);
  864. #if MVS
  865.       if (p) strcat(tname,p);
  866.    }
  867. #endif                    /* MVS */
  868.       fname = fopen(tname,ReadBinary);
  869. #endif                                  /* WATERLOO_C_V3_0 */
  870.       }
  871.  
  872.    if (fname == NULL)                /* try the name as given */
  873.  
  874. #ifdef WATERLOO_C_V3_0
  875.       {
  876.       /*
  877.        *  Prevent interpretation of \n in binary files.
  878.        */
  879.       char tname[100];
  880.       strcpy(tname,name);
  881.       strcat(tname," (BIN");
  882.       fname = fopen(tname,ReadText);
  883.       }
  884. #else                    /* WATERLOO_C_V3_0 */
  885.       fname = fopen(name,ReadBinary);
  886. #endif                    /* WATERLOO_C_V3_0 */
  887.  
  888.    if (fname == NULL)
  889.       error("cannot open interpreter file");
  890.  
  891.    setbuf(fname,icodebuf);
  892.  
  893. #ifdef Header
  894.    if (fseek(fname, (long)MaxHeader, 0) == -1)
  895.       error("can't read interpreter file header");
  896. #endif                    /* Header */
  897.  
  898.    if (fread((char *)&hdr, sizeof(char), sizeof(hdr), fname) != sizeof(hdr))
  899.       error("can't read interpreter file header");
  900.  
  901.  
  902.    k_trace = hdr.trace;
  903.  
  904.  
  905. #ifdef EnvVars
  906.    /*
  907.     * Examine the environment and make appropriate settings.    [[I?]]
  908.     */
  909.    envset();
  910. #endif                    /* EnvVars */
  911.  
  912.    /*
  913.     * Convert stack sizes from words to bytes.
  914.     */
  915.  
  916. #ifndef SCO_XENIX
  917.    stksize *= WordSize;
  918.    mstksize *= WordSize;
  919. #else                    /* SCO_XENIX */
  920.    /*
  921.     * This is a work-around for bad generated code for *= (as above)
  922.     *  produced by the SCO XENIX C Compiler for the large memory model.
  923.     *  It relies on the fact that WordSize is 4.
  924.     */
  925.    stksize += stksize;
  926.    stksize += stksize;
  927.    mstksize += mstksize;
  928.    mstksize += mstksize;
  929. #endif                    /* SCO_XENIX */
  930.  
  931. #if IntBits == 16
  932.    if (mstksize > MaxBlock)
  933.       fatalerr(-316, NULL);
  934.    if (stksize > MaxBlock)
  935.       fatalerr(-318, NULL);
  936. #endif                    /* IntBits == 16 */
  937.  
  938.    /*
  939.     * Allocate memory for various regions.
  940.     */
  941.    initalloc(hdr.hsize);
  942.  
  943.    /*
  944.     * Establish pointers to icode data regions.        [[I?]]
  945.     */
  946.  
  947.    records = (word *)(code + hdr.records);
  948.    ftabp = (word *)(code + hdr.ftab);
  949.    fnames = (dptr)(code + hdr.fnames);
  950.    globals = efnames = (dptr)(code + hdr.globals);
  951.    gnames = eglobals = (dptr)(code + hdr.gnames);
  952.    statics = egnames = (dptr)(code + hdr.statics);
  953.    estatics = (dptr)(code + hdr.filenms);
  954.    filenms = (struct ipc_fname *)estatics;
  955.    efilenms = (struct ipc_fname *)(code + hdr.linenums);
  956.    ilines = (struct ipc_line *)efilenms;
  957.    elines = (struct ipc_line *)(code + hdr.strcons);
  958.    strcons = (char *)elines;
  959.  
  960.    /*
  961.     * Allocate stack and initialize &main.
  962.     */
  963.  
  964.    stack = (word *)malloc((msize)mstksize);
  965.    if (stack == NULL)
  966.       fatalerr(-303, NULL);
  967.    mainhead = (struct b_coexpr *)stack;
  968.    mainhead->title = T_Coexpr;
  969.  
  970. #ifdef Coexpr
  971.    mainhead->es_actstk = alcactiv();
  972.    if (mainhead->es_actstk == NULL)
  973.       fatalerr(0, NULL);
  974.    if (pushact(mainhead, mainhead) == Error)
  975.       fatalerr(0, NULL);
  976. #endif                    /* Coexpr */
  977.  
  978.    mainhead->id = 1;
  979.    mainhead->size = 1;            /* pretend main() does an activation */
  980.  
  981.    mainhead->freshblk = nulldesc;    /* &main has no refresh block. */
  982.                     /*  This really is a bug. */
  983.  
  984.    /*
  985.     * Point &main at the co-expression block for the main procedure and set
  986.     *  k_current, the pointer to the current co-expression, to &main.
  987.     */
  988.    k_main.dword = D_Coexpr;
  989.    BlkLoc(k_main) = (union block *) mainhead;
  990.    k_current = k_main;
  991.    
  992.    /*
  993.     * Read the interpretable code and data into memory.
  994.     */
  995.  
  996.    if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) !=
  997.       hdr.hsize) {
  998.       fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n",
  999.     (long)hdr.hsize,(long)cbread);
  1000.       error("can't read interpreter code");
  1001.       }
  1002.    fclose(fname);
  1003.  
  1004. /*
  1005.  * Make sure the version number of the icode matches the interpreter version.
  1006.  */
  1007.  
  1008.    if (strcmp((char *)hdr.config,IVersion)) {
  1009.       fprintf(stderr,"icode version mismatch\n");
  1010.       fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config);
  1011.       fprintf(stderr,"\texpected version: %s\n",IVersion);
  1012.       error("cannot run");
  1013.       }
  1014.  
  1015.    /*
  1016.     * Resolve references from icode to run-time system.
  1017.     */
  1018.    resolve();
  1019.  
  1020. #ifdef ExecImages
  1021. btinit:
  1022. #endif                    /* ExecImages */
  1023.  
  1024. /*
  1025.  * The following code is operating-system dependent [@imain.04].  Allocate and
  1026.  *  assign a buffer to stderr if possible.
  1027.  */
  1028.  
  1029. #if PORT
  1030.    /* probably nothing */
  1031. Deliberate Syntax Error
  1032. #endif                    /* PORT */
  1033.  
  1034. #if AMIGA || HIGHC_386 || MVS || VM
  1035.    /* not done */
  1036. #endif                    /* AMIGA */
  1037.  
  1038. #if ATARI_ST || MACINTOSH || UNIX || MSDOS || OS2 || VMS
  1039.  
  1040.    if (noerrbuf)
  1041.       setbuf(stderr, NULL);
  1042.    else {
  1043.       char *buf;
  1044.       
  1045.       buf = (char *)malloc((msize)BUFSIZ);
  1046.       if (buf == NULL)
  1047.         fatalerr(-305, NULL);
  1048.       setbuf(stderr, buf);
  1049.       }
  1050. #endif                    /* ATARI_ST || MACINTOSH || UNIX ... */
  1051.  
  1052. /*
  1053.  * End of operating-system specific code.
  1054.  */
  1055.  
  1056. #ifdef MemMon
  1057.    /*
  1058.     * Initialize the memory monitoring system, if configured.
  1059.     */
  1060.    MMInit(name);
  1061. #endif                    /* MemMon */
  1062.  
  1063. #ifdef EvalTrace
  1064.    /*
  1065.     * Initialize evaluation tracing system
  1066.     */
  1067.    TRInit(name);
  1068. #endif                    /* EvalTrace */
  1069.  
  1070.    /*
  1071.     * Start timing execution.
  1072.     */
  1073.  
  1074.    millisec();
  1075.    }
  1076.  
  1077. /*
  1078.  * Service routines related to getting things started.
  1079.  */
  1080.  
  1081. /*
  1082.  * resolve - perform various fix-ups on the data read from the icode
  1083.  *  file.
  1084.  */
  1085. novalue resolve()
  1086.    {
  1087.    register word i;
  1088.    register struct b_proc *pp;
  1089.    register dptr dp;
  1090.    extern Omkrec();
  1091.    extern int ftsize;
  1092.  
  1093.    extern struct b_proc *functab[];
  1094.  
  1095.    /*
  1096.     * Scan the global variable array for procedures and fill in appropriate
  1097.     *  addresses.
  1098.     */
  1099.    for (dp = globals; dp < eglobals; dp++) {
  1100.       if ((*dp).dword != D_Proc)
  1101.          continue;
  1102.  
  1103.       /*
  1104.        * The second word of the descriptor for procedure variables tells
  1105.        *  where the procedure is.  Negative values are used for built-in
  1106.        *  procedures and positive values are used for Icon procedures.
  1107.        */
  1108.       i = IntVal(*dp);
  1109.  
  1110.       if (i < 0) {
  1111.          /*
  1112.           * *dp names a built-in function, negate i and use it as an index
  1113.           *  into functab to get the location of the procedure block.
  1114.           */
  1115.          i = -i;
  1116.          if (i > ftsize) {
  1117.             *dp = nulldesc;        /* undefined, set to &null */
  1118.             continue;
  1119.             }
  1120.          BlkLoc(*dp) = (union block *)functab[i-1];
  1121.          }
  1122.       else {
  1123.  
  1124.          /*
  1125.           * *dp names an Icon procedure or a record.  i is an offset to
  1126.           *  location of the procedure block in the code section.  Point
  1127.           *  pp at the block and replace BlkLoc(*dp).
  1128.           */
  1129.          pp = (struct b_proc *)(code + i);
  1130.          BlkLoc(*dp) = (union block *)pp;
  1131.  
  1132.          /*
  1133.           * Relocate the address of the name of the procedure.
  1134.           */
  1135.          StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname);
  1136.          if (pp->ndynam == -2)
  1137.             /*
  1138.              * This procedure is a record constructor.    Make its entry point
  1139.              *    be the entry point of Omkrec().
  1140.              */
  1141.             pp->entryp.ccode = Omkrec;
  1142.          else {
  1143.             /*
  1144.              * This is an Icon procedure.  Relocate the entry point and
  1145.              *    the names of the parameters, locals, and static variables.
  1146.              */
  1147.             pp->entryp.icode = code + pp->entryp.ioff;
  1148.             for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++)
  1149.                StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]);
  1150.             }
  1151.  
  1152. #ifndef BoundFunctions
  1153.          }
  1154. #endif                    /* BoundFunctions */
  1155.  
  1156.       }
  1157.  
  1158.    /*
  1159.     * Relocate the names of the fields.
  1160.     */
  1161.  
  1162.    for (dp = fnames; dp < efnames; dp++)
  1163.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1164.  
  1165.    /*
  1166.     * Relocate the names of the global variables.
  1167.     */
  1168.    for (dp = gnames; dp < egnames; dp++)
  1169.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1170.  
  1171.    }
  1172.  
  1173. #ifdef EnvVars
  1174. /*
  1175.  * Check for environment variables that Icon uses and set system
  1176.  *  values as is appropriate.
  1177.  */
  1178. novalue envset()
  1179.    {
  1180.    register char *p;
  1181.  
  1182.    if ((p = getenv("NOERRBUF")) != NULL)
  1183.       noerrbuf++;
  1184.    env_int("TRACE", &k_trace, 0, (uword)0);
  1185.    env_int("COEXPSIZE", &stksize, 1, (uword)MaxUnsigned);
  1186.    env_int("STRSIZE", &ssize, 1, (uword)MaxBlock);
  1187.    env_int("HEAPSIZE", &abrsize, 1, (uword)MaxBlock);
  1188.    env_int("BLOCKSIZE", &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1189.    env_int("BLKSIZE", &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1190.    env_int("STATSIZE", &statsize, 1, (uword)MaxBlock);
  1191.    env_int("STATINCR", &statincr, 1, (uword)MaxBlock);
  1192.    env_int("MSTKSIZE", &mstksize, 1, (uword)MaxUnsigned);
  1193.  
  1194. #ifdef FixedRegions
  1195.    env_int("QLSIZE", &qualsize, 1, (uword)MaxBlock);
  1196. #endif                    /* FixedRegions */
  1197.  
  1198. /*
  1199.  * The following code is operating-system dependent [@imain.05].  Check any
  1200.  *  system-dependent environment variables.
  1201.  */
  1202.  
  1203. #if PORT
  1204.    /* nothing to do */
  1205. Deliberate Syntax Error
  1206. #endif                    /* PORT */
  1207.  
  1208. #if AMIGA
  1209.    if ((p = getenv("CHECKBREAK")) != NULL)
  1210.       chkbreak++;
  1211. #endif                    /* AMIGA */
  1212.  
  1213. #if ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM
  1214.    /* nothing to do */
  1215. #endif                    /* ATARI_ST || HIGHC_386 || ... */
  1216.  
  1217. #if VMS
  1218.    {
  1219.       extern word memsize;
  1220.       env_int("MAXMEM", &memsize, 1, MaxBlock);
  1221.    }
  1222. #endif                    /* VMS */
  1223.  
  1224. /*
  1225.  * End of operating-system specific code.
  1226.  */
  1227.  
  1228.    if ((p = getenv("ICONCORE")) != NULL && *p != '\0') {
  1229.  
  1230. /*
  1231.  * The following code is operating-system dependent [@imain.06].  Set trap to
  1232.  *  give dump on abnormal termination if ICONCORE is set.
  1233.  */
  1234.  
  1235. #if PORT
  1236.    /* can't handle */
  1237. Deliberate Syntax Error
  1238. #endif                    /* PORT */
  1239.  
  1240. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH
  1241.    /* can't handle */
  1242. #endif                    /* AMIGA || ATARI_ST || ... */
  1243.  
  1244. #if MSDOS
  1245. #if LATTICE || TURBO
  1246.       signal(SIGFPE, SIG_DFL);
  1247. #endif                    /* LATTICE || TURBO */
  1248. #endif                    /* MSDOS */
  1249.  
  1250. #if MVS || VM
  1251.       /* Really nothing to do. */
  1252. #endif                    /* MVS || VM */
  1253.  
  1254. #if OS2
  1255.       signal(SIGSEGV, SIG_DFL);
  1256.       signal(SIGFPE, SIG_DFL);
  1257. #endif                    /* OS2 */
  1258.  
  1259. #if UNIX || VMS
  1260.       signal(SIGSEGV, SIG_DFL);
  1261. #endif                    /* UNIX || VMS */
  1262.  
  1263. /*
  1264.  * End of operating-system specific code.
  1265.  */
  1266.       dodump++;
  1267.       }
  1268.    }
  1269.  
  1270. static novalue env_err(msg, name, val)
  1271. char *msg;
  1272. char *name;
  1273. char *val;
  1274. {
  1275.    char msg_buf[100];
  1276.  
  1277.    strncpy(msg_buf, msg, 99);
  1278.    strncat(msg_buf, ": ", 99 - strlen(msg_buf));
  1279.    strncat(msg_buf, name, 99 - strlen(msg_buf));
  1280.    strncat(msg_buf, "=", 99 - strlen(msg_buf));
  1281.    strncat(msg_buf, val, 99 - strlen(msg_buf));
  1282.    error(msg_buf);
  1283. }
  1284.  
  1285. /*
  1286.  * env_int - get the value of an integer-valued environment variable.
  1287.  */
  1288. novalue env_int(name, variable, non_neg, limit)
  1289. char *name;
  1290. word *variable;
  1291. int non_neg;
  1292. uword limit;
  1293. {
  1294.    char *value;
  1295.    char *s;
  1296.    register uword n = 0;
  1297.    register uword d;
  1298.    int sign = 1;
  1299.  
  1300.    if ((value = getenv(name)) == NULL || *value == '\0')
  1301.       return;
  1302.  
  1303.    s = value;
  1304.    if (*s == '-') {
  1305.       if (non_neg)
  1306.          env_err("environment variable out of range", name, value);
  1307.       sign = -1;
  1308.       ++s;
  1309.       }
  1310.    else if (*s == '+')
  1311.       ++s;
  1312.    while (isdigit(*s)) {
  1313.       d = *s++ - '0';
  1314.       /*
  1315.        * See if 10 * n + d > limit, but do it so there can be no overflow.
  1316.        */
  1317.       if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0))
  1318.      env_err("environment variable out of range", name, value);
  1319.       n = n * 10 + d;
  1320.       }
  1321.    if (*s != '\0')
  1322.       env_err("environment variable not numeric", name, value);
  1323.    *variable = sign * n;
  1324. }
  1325. #endif                    /* EnvVars */
  1326.  
  1327. /*
  1328.  * Termination routines.
  1329.  */
  1330.  
  1331. /*
  1332.  * Produce run-time error 204 on floating-point traps.
  1333.  */
  1334.  
  1335. novalue fpetrap()
  1336.    {
  1337.    fatalerr(-204, NULL);
  1338.    }
  1339.  
  1340. /*
  1341.  * Produce run-time error 320 on ^C interrupts. Not used at present,
  1342.  *  since malfunction may occur during traceback.
  1343.  */
  1344. novalue inttrap()
  1345.    {
  1346.    fatalerr(-320, NULL);
  1347.    }
  1348.  
  1349. /*
  1350.  * Produce run-time error 302 on segmentation faults.
  1351.  */
  1352. novalue segvtrap()
  1353.    {
  1354.    fatalerr(-302, NULL);
  1355.    }
  1356.  
  1357. #if MVS || VM
  1358. novalue fixtrap()
  1359.    {
  1360.    fatalerror(-203, NULL);
  1361.    }
  1362. #endif                    /* MVS || VM */
  1363.  
  1364. /*
  1365.  * error - print error message s; used only in startup code.
  1366.  */
  1367. novalue error(s)
  1368. char *s;
  1369.    {
  1370.  
  1371.  
  1372.    fprintf(stderr, "error in startup code\n%s\n", s);
  1373.  
  1374.    fflush(stderr);
  1375.    if (dodump)
  1376.       abort();
  1377.    c_exit(ErrorExit);
  1378.    }
  1379.  
  1380. /*
  1381.  * syserr - print s as a system error.
  1382.  */
  1383. novalue syserr(s)
  1384. char *s;
  1385.    {
  1386.  
  1387.    
  1388.    if (pfp != 0)
  1389.       fprintf(stderr, "System error at line %ld in %s\n%s\n",
  1390.          (long)findline(ipc.opnd), findfile(ipc.opnd), s);
  1391.    else
  1392.       fprintf(stderr, "System error in startup code\n%s\n", s);
  1393.  
  1394.    fflush(stderr);
  1395.    if (dodump)
  1396.       abort();
  1397.    c_exit(ErrorExit);
  1398.    }
  1399.  
  1400. /*
  1401.  * runerr - print message corresponding to error |n|;  if n > 0,
  1402.  *  print it as the offending value.
  1403.  */
  1404.  
  1405. novalue runerr(n, v)
  1406.  
  1407. register int n;
  1408. dptr v;
  1409.    {
  1410.    register struct errtab *p;
  1411.  
  1412.    if (n != 0) {
  1413.       k_errornumber = n;
  1414.       if (n > 0)
  1415.          k_errorvalue = *v;
  1416.       else
  1417.          k_errorvalue = nulldesc;
  1418.       }
  1419.  
  1420.    /*
  1421.     * Take absolute value of error number
  1422.     */
  1423.    n = (k_errornumber > 0 ? k_errornumber : -k_errornumber);
  1424.  
  1425.    k_errortext = "";
  1426.    for (p = errtab; p->err_no > 0; p++)
  1427.       if (p->err_no == n) {
  1428.          k_errortext = p->errmsg;
  1429.          break;
  1430.          }
  1431.  
  1432.  
  1433.    if (pfp != 0) {
  1434.       if (k_error == 0) {
  1435.          fprintf(stderr, "Run-time error %d\nFile %s; Line %ld\n",
  1436.             n, findfile(ipc.opnd), (long)findline(ipc.opnd));
  1437.          }
  1438.       else {
  1439.          k_error--;
  1440.          return;
  1441.          }
  1442.       }
  1443.    else
  1444.       fprintf(stderr, "Run-time error %d in startup code\n", n);
  1445.    fprintf(stderr, "%s\n", k_errortext);
  1446.  
  1447.    if (k_errornumber > 0) {
  1448.       fprintf(stderr, "offending value: ");
  1449.       outimage(stderr, &k_errorvalue, 0);
  1450.       putc('\n', stderr);
  1451.       }
  1452.    fflush(stderr);
  1453.  
  1454. #ifdef MemMon
  1455.    {
  1456.       char buf[40];
  1457.       sprintf(buf,"Run-time error %d: ",n);
  1458.       MMTerm(buf,k_errortext);
  1459.    }
  1460. #endif                /* MemMon */
  1461.  
  1462. #ifdef EvalTrace
  1463.    {
  1464.       char buf[40];
  1465.       sprintf(buf,"Run-time error %d: ",n);
  1466.       TRTerm(buf,k_errortext);
  1467.    }
  1468. #endif                /* EvalTrace */
  1469.  
  1470. #ifdef TraceBack
  1471.    if (pfp == 0) {        /* skip if start-up problem */
  1472.       if (dodump)
  1473.          abort();
  1474.       c_exit(ErrorExit);
  1475.       }
  1476.  
  1477.    {
  1478.    struct pf_marker *origpfp = pfp;
  1479.    dptr arg;
  1480.    struct b_proc *cproc;
  1481.    inst cipc;
  1482.  
  1483.    fprintf(stderr, "Trace back:\n");
  1484.  
  1485.    /*
  1486.     * Chain back through the procedure frame markers, looking for the
  1487.     *  first one, while building a foward chain of pointers through
  1488.     *  the expression frame pointers.
  1489.     */
  1490.  
  1491.    for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) {
  1492.       (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp;
  1493.       }
  1494.  
  1495.    /* Now start from the base procedure frame marker, producing a listing
  1496.     *  of the procedure calls up through the last one.
  1497.     */
  1498.  
  1499.    while (pfp) {
  1500.       arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1];
  1501.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1502.       /*
  1503.        * The ipc in the procedure frame points after the "invoke n".
  1504.        */
  1505.       cipc = pfp->pf_ipc;
  1506.       --cipc.opnd;
  1507.       --cipc.op;
  1508.  
  1509.       xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd),
  1510.          findfile(cipc.opnd));
  1511.       /*
  1512.        * On the last call, show both the call and the offending expression.
  1513.        */
  1514.       if (pfp == origpfp) {
  1515.          ttrace();
  1516.          break;
  1517.          }
  1518.  
  1519.       pfp = (struct pf_marker *)(pfp->pf_efp);
  1520.       }
  1521.    }
  1522. #endif                     /* TraceBack */
  1523.  
  1524.  
  1525.    if (dodump)
  1526.       abort();
  1527.    c_exit(ErrorExit);
  1528.    }
  1529.  
  1530. /*
  1531.  * c_exit(i) - flush all buffers and exit with status i.
  1532.  */
  1533. novalue c_exit(i)
  1534. int i;
  1535. {
  1536.  
  1537. #ifdef MemMon
  1538.    MMTerm("","");
  1539. #endif                    /* MemMon */
  1540.  
  1541. #ifdef EvalTrace
  1542.    TRTerm("","");
  1543. #endif                    /* EvalTrace */
  1544.  
  1545. #ifdef TallyOpt
  1546.    {
  1547.    int j;
  1548.  
  1549.    if (tallyopt) {
  1550.       fprintf(stderr,"tallies: ");
  1551.       for (j=0; j<16; j++)
  1552.          fprintf(stderr," %ld", (long)tallybin[j]);
  1553.          fprintf(stderr,"\n");
  1554.          }
  1555.       }
  1556. #endif                    /* TallyOpt */
  1557.  
  1558.  
  1559.    exit(i);
  1560. }
  1561.  
  1562. /*
  1563.  * err() is called if an erroneous situation occurs in the virtual
  1564.  *  machine code.  It is typed as int to avoid declaration problems
  1565.  *  elsewhere.
  1566.  */
  1567. int err()
  1568. {
  1569.    syserr("call to 'err'\n");
  1570.    return 1;        /* unreachable; make compilers happy */
  1571. }
  1572.  
  1573. novalue fatalerr(n, v)
  1574. int n;
  1575. dptr v;
  1576.    {
  1577.    k_error = 0;
  1578.    runerr(n, v);
  1579.    }
  1580.  
  1581. novalue datainit()
  1582.    {
  1583.  
  1584.    /*
  1585.     * Initializations that cannot be performed statically (at least for
  1586.     * some compilers).                    [[I?]]
  1587.     */
  1588.  
  1589.    k_errout.fd = stderr;
  1590.    k_errout.fname.dword = 7;
  1591.    StrLoc(k_errout.fname) = "&errout";
  1592.    k_errout.status = Fs_Write;
  1593.  
  1594.    k_input.fd = stdin;
  1595.    k_input.fname.dword = 6;
  1596.    StrLoc(k_input.fname) = "&input";
  1597.    k_input.status = Fs_Read;
  1598.  
  1599.    k_output.fd = stdout;
  1600.    k_output.fname.dword = 7;
  1601.    StrLoc(k_output.fname) = "&output";
  1602.    k_output.status = Fs_Write;
  1603.  
  1604.    IntVal(tvky_pos.kyval) = 1;
  1605.    StrLen(tvky_pos.kyname) = 4;
  1606.    StrLoc(tvky_pos.kyname) = "&pos";
  1607.  
  1608.    IntVal(tvky_ran.kyval) = 0;
  1609.    StrLen(tvky_ran.kyname) = 7;
  1610.    StrLoc(tvky_ran.kyname) = "&random";
  1611.  
  1612.    StrLen(tvky_sub.kyval) = 0;
  1613.    StrLoc(tvky_sub.kyval) = "";
  1614.    StrLen(tvky_sub.kyname) = 8;
  1615.    StrLoc(tvky_sub.kyname) = "&subject";
  1616.  
  1617.    IntVal(tvky_trc.kyval) = 0;
  1618.    StrLen(tvky_trc.kyname) = 6;
  1619.    StrLoc(tvky_trc.kyname) = "&trace";
  1620.  
  1621.    IntVal(tvky_err.kyval) = 0;
  1622.    StrLen(tvky_err.kyname) = 6;
  1623.    StrLoc(tvky_err.kyname) = "&error";
  1624.  
  1625.  
  1626.    StrLen(blank) = 1;
  1627.    StrLoc(blank) = " ";
  1628.    StrLen(emptystr) = 0;
  1629.    StrLoc(emptystr) = "";
  1630.    BlkLoc(errout) = (union block *) &k_errout;
  1631.    BlkLoc(input) = (union block *) &k_input;
  1632.    StrLen(lcase) = 26;
  1633.    StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz";
  1634.    StrLen(letr) = 1;
  1635.    StrLoc(letr) = "r";
  1636.    IntVal(nulldesc) = 0;
  1637.    k_errorvalue = nulldesc;
  1638.    IntVal(onedesc) = 1;
  1639.    StrLen(ucase) = 26;
  1640.    StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  1641.    IntVal(zerodesc) = 0;
  1642.  
  1643.    maps2 = nulldesc;
  1644.    maps3 = nulldesc;
  1645.  
  1646. #ifdef MultipleRuns
  1647.  
  1648.    mstksize = MStackSize;        /* initial size of main stack */
  1649.    stksize = StackSize;            /* co-expression stack size */
  1650.    ssize = MaxStrSpace;            /* initial string space size (bytes) */
  1651.    abrsize = MaxAbrSize;        /* initial size of allocated block
  1652.                          region (bytes) */                                    
  1653. #ifdef FixedRegions
  1654.    qualsize = QualLstSize;        /* size of quallist for fixed regions */
  1655. #endif                    /* FixedRegions */
  1656.  
  1657.    ntended = 0;                /* number of active tended descrips */
  1658.    dodump = 0;                /* produce dump on error */
  1659.    mterm = Op_Quit;
  1660.  
  1661. #ifdef IconCalling
  1662.    fterm = Op_FQuit;
  1663. #endif                    /* IconCalling */
  1664.  
  1665. #ifdef ExecImages
  1666.    dumped = 0;                /* This is a dumped image. */
  1667. #endif                    /* ExecImages */
  1668.  
  1669.                     /* In module interp.c:    */
  1670.    pfp = 0;                /* Procedure frame pointer */
  1671.    sp = NULL;                /* Stack pointer */
  1672.  
  1673.  
  1674.                     /* In module rmemmgt.c:    */
  1675.    coexp_ser = 2;
  1676.    list_ser = 1;
  1677.    set_ser = 1;
  1678.    table_ser = 1;
  1679.  
  1680.    coll_stat = 0;
  1681.    coll_str = 0;
  1682.    coll_blk = 0;
  1683.    coll_tot = 0;
  1684.    
  1685.  
  1686. #endif                    /* MultipleRuns */
  1687.    }
  1688.  
  1689.